{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit ZipWriter;

interface

uses
  Classes, SysUtils, zstreamCustom, ZipCommon, MiscUtils, Windows;

type
  TCompressionMethod = (cmDeflate, cmStore);

  TStreamWriteEvent = procedure(Sender: TStream; const Buffer; Count: Integer) of object;

  TOutputFilterStream = class(TStream)
  private
    FTarget: TStream;
    FBytesWritten: Int64;
    FOnWrite: TStreamWriteEvent;
  public
    constructor Create(Target: TStream);
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;

    { unsupported operations }
    function Read(var Buffer; Count: Longint): Longint; override;
    procedure SetSize(NewSize: Longint); override;

    property OnWrite: TStreamWriteEvent read FOnWrite write FOnWrite;
  end;

  TZipWriter = class
  private type
    TZipEntry = class
    private
      FHeader: TZipCentralFileHeader;
      FFileName: String;
      FDataOffset: Integer;
    end;
    TZipEntryList = TGenericObjectList<TZipEntry>;
  private
    FOutput: TStream;
    FCompressionStream: TCompressionStream;
    FEntries: TZipEntryList;
    FWriting: Boolean;
    FCrc32: Cardinal;
    FCrc32Filter: TOutputFilterStream;
    FCompressionMethod: TCompressionMethod;
    procedure WriteLocalHeaders;
    procedure WriteDirectory;
    procedure CheckOutputSizeLimit;
    function GetEntryStream: TStream;
    procedure Crc32FilterWrite(Sender: TStream; const Buffer; Count: Integer);
  public
    constructor Create(Output: TStream);
    destructor Destroy; override;
    procedure CreateEntry(const FileName: String; CompressionMethod: TCompressionMethod);
    procedure CloseEntry;
    procedure Commit;

    property EntryStream: TStream read GetEntryStream;
  end;

implementation

const
  DEFAULT_DOS_DATE = (2000 - 1980) shl 9 + 1{ month } shl 5 + 1{ day of month }; { January 1, 2000 }
  DEFAULT_DOS_TIME = 0; { 00:00:00 }

function CentralToLocal(const c: TZipCentralFileHeader): TZipLocalFileHeader;
begin
  Result.Signature := ZIP_LOCAL_FILE_HEADER_SIGNATURE;
  Result.VersionToExtract := c.VersionToExtract;
  Result.Flags := c.Flags;
  Result.CompressionMethod := c.CompressionMethod;
  Result.LastModFileTime := c.LastModFileTime;
  Result.LastModFileDate := c.LastModFileDate;
  Result.Crc32 := c.Crc32;
  Result.CompressedSize := c.CompressedSize;
  Result.UncompressedSize := c.UncompressedSize;
  Result.FileNameLength := c.FileNameLength;
  Result.ExtraFieldLength := c.ExtraFieldLength;
end;

procedure CheckSizeLimit(const Size: Int64);
begin
  if Size > MaxInt then
    raise Exception.Create('File is too big.');
end;

{ TZipWriter }

procedure TZipWriter.CheckOutputSizeLimit;
begin
  CheckSizeLimit(FOutput.Position);
end;

procedure TZipWriter.CloseEntry;
var
  e: TZipEntry;
  UncompressedSize: Int64;
begin
  Assert( FWriting );
  
  UncompressedSize := FCrc32Filter.Position;
  FreeAndNil(FCrc32Filter);
  if FCompressionStream <> nil then
  begin
    FCompressionStream.Flush;
    FreeAndNil(FCompressionStream);
  end;

  CheckSizeLimit(UncompressedSize);
  CheckOutputSizeLimit;

  e := FEntries.Last;
  e.FHeader.Signature := ZIP_CENTRAL_FILE_HEADER_SIGNATURE;
  e.FHeader.VersionMadeBy := ZIP_VERSION_2_0;
  e.FHeader.VersionToExtract := ZIP_VERSION_2_0;
  if FCompressionMethod = cmDeflate then
    e.FHeader.CompressionMethod := ZIP_METHOD_DEFLATE
  else
    e.FHeader.CompressionMethod := ZIP_METHOD_STORE;
  e.FHeader.LastModFileTime := DEFAULT_DOS_TIME;
  e.FHeader.LastModFileDate := DEFAULT_DOS_DATE;
  e.FHeader.Crc32 := FCrc32;
  e.FHeader.CompressedSize := FOutput.Position - e.FDataOffset;
  e.FHeader.UncompressedSize := UncompressedSize;
  e.FHeader.FileNameLength := Length(e.FFileName);
  e.FHeader.ExternalFileAttributes := FILE_ATTRIBUTE_ARCHIVE;

  FWriting := FALSE;
end;

procedure TZipWriter.Commit;
begin
  Assert( not FWriting );
  WriteDirectory;
  WriteLocalHeaders;
end;

procedure TZipWriter.Crc32FilterWrite(Sender: TStream; const Buffer;
  Count: Integer);
begin
  FCrc32 := crc32(FCrc32, @Buffer, Count);
end;

constructor TZipWriter.Create(Output: TStream);
begin
  inherited Create;
  Assert( Output.Size = 0 );
  FOutput := Output;
  FEntries := TZipEntryList.Create;
end;

procedure TZipWriter.CreateEntry(const FileName: String; CompressionMethod: TCompressionMethod);
var
  h: TZipLocalFileHeader;
  Entry: TZipEntry;
  Next: TStream;
begin
  Assert( not FWriting );
  if Length(FileName) > $ffff then
    raise Exception.Create('File name is too long.');
  CheckOutputSizeLimit;

  Entry := TZipEntry.Create;
  FEntries.AddSafely(Entry);

  Entry.FFileName := FileName;
  Entry.FHeader.LocalHeaderOffset := FOutput.Position;

  {$HINTS OFF}
  FillChar(h, SizeOf(h), 0);
  {$HINTS ON}
  FOutput.WriteBuffer(h, SizeOf(h));
  WriteStreamString(FOutput, FileName);
  CheckOutputSizeLimit;
  Entry.FDataOffset := FOutput.Position;

  FCompressionMethod := CompressionMethod;
  if CompressionMethod = cmDeflate then
  begin
    FCompressionStream := TCompressionStream.Create(clDefault, FOutput, TRUE, FALSE);
    Next := FCompressionStream;
  end
  else
    Next := FOutput;

  FCrc32Filter := TOutputFilterStream.Create(Next);
  FCrc32Filter.OnWrite := Crc32FilterWrite;
  FCrc32 := crc32(0, nil, 0);

  FWriting := TRUE;
end;

destructor TZipWriter.Destroy;
begin
  FreeAndNil(FCrc32Filter);
  FreeAndNil(FCompressionStream);
  FreeAndNil(FEntries);
  inherited;
end;

function TZipWriter.GetEntryStream: TStream;
begin
  Assert( FWriting );
  Result := FCrc32Filter;
end;

procedure TZipWriter.WriteDirectory;
var
  e: TZipEndDirectoryRecord;
  Entry: TZipEntry;
begin
  CheckOutputSizeLimit;

  {$HINTS OFF}
  FillChar(e, SizeOf(e), 0);
  {$HINTS ON}
  e.DirOffset := FOutput.Position;

  for Entry in FEntries do
  begin
    FOutput.WriteBuffer(Entry.FHeader, SizeOf(Entry.FHeader));
    WriteStreamString(FOutput, Entry.FFileName);
  end;
  CheckOutputSizeLimit;

  e.Signature := ZIP_END_DIRECTORY_RECORD_SIGNATURE;
  e.DiskEntryCount := FEntries.Count;
  e.TotalEntryCount := e.DiskEntryCount;
  e.DirSize := FOutput.Position - e.DirOffset;
  FOutput.WriteBuffer(e, SizeOf(e));
  CheckOutputSizeLimit;
end;

procedure TZipWriter.WriteLocalHeaders;
var
  i: Integer;
  Entry: TZipEntry;
  h: TZipLocalFileHeader;
begin
  for i := FEntries.Count-1 downto 0 do
  begin
    Entry := FEntries[i];
    FOutput.Seek(Entry.FHeader.LocalHeaderOffset, soFromBeginning);
    h := CentralToLocal(Entry.FHeader);
    FOutput.WriteBuffer(h, SizeOf(h));
  end;
end;

{ TOutputFilterStream }

constructor TOutputFilterStream.Create(Target: TStream);
begin
  inherited Create;
  FTarget := Target;
end;

{$WARNINGS OFF}
function TOutputFilterStream.Read(var Buffer; Count: Integer): Longint;
begin
  Assert( FALSE );
end;
{$WARNINGS ON}

function TOutputFilterStream.Seek(const Offset: Int64;
  Origin: TSeekOrigin): Int64;
begin
  Assert( Origin = soCurrent );
  Assert( Offset = 0 );
  Result := FBytesWritten;
end;

procedure TOutputFilterStream.SetSize(NewSize: Integer);
begin
  Assert( FALSE );
end;

function TOutputFilterStream.Write(const Buffer; Count: Integer): Longint;
begin
  Result := FTarget.Write(Buffer, Count);
  Inc(FBytesWritten, Result);
  if Assigned(FOnWrite) then
    FOnWrite(Self, Buffer, Result);
end;

end.
